COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DECLARE (SETQ NO-DISK-HACKS T))
C00017 ENDMK
C⊗;
(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (REQUIRE UTIL 1 DSK (AID RPG)))
(DECLARE (READ))
(REQUIRE UTIL 1 DSK (AID RPG))

(DEFPROP COMPFCNS
 (COMPFCNS COMPL
	   COMP
	   SUBSTACK
	   PRUP
	   MKPUSH
	   COMPEXP
	   STACKUP
	   CCCHAIN
	   COMPC
	   COMCOND
	   COMPLISA
	   CCOUNT
	   LOADAC
	   COMPLIS
	   CLASSIFY
	   CLASS1
	   CLASS2
	   MKJRST
	   COMBOOL
	   COMPANDOR
	   COMPANDOR1
	   FLAT)
VALUE)

(DEFUN FEXPR COMPL(FILE)
	(UWRITE)
	(APPLY 'EREAD FILE)
       	(SELECT-DISK-INPUT (READ-UNTIL-EOF WITH Z DO 
	(COND ((OR (EQ (CAR Z) (QUOTE DEFUN))
		   (AND	(EQ (CAR Z) (QUOTE DEFPROP))
			(EQ (CADDDR Z) (QUOTE EXPR))))
	       (PROG (PROG)
		     (SETQ PROG
			   (COND ((EQ (CAR Z) (QUOTE DEFUN))
				  (COMP	(CADR Z)
					(CADDR Z)
					(CADDDR Z)))
				 (T
				  (COMP	(CADR Z)
					(CADR (CADDR Z))
					(CADDR (CADDR Z))))))
		     (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		     (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	      (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
       	(APPLY 'UFILE (LIST (CAR FILE) 'LAP))
	(QUOTE ENDCOMP)))


(DEFUN COMP(FN VARS EXP)
  ((LAMBDA(VPR N)
    (FLAT (LIST	(LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
		(MKPUSH N 1)
		(COMPEXP EXP (MINUS N) VPR)
		(SUBSTACK N)
		(QUOTE ((POPJ P) (LABEL NIL))))
	  NIL))
   (PRUP VARS 1)
   (LENGTH VARS)))

(DEFUN SUBSTACK(N)
  (COND	((= N 0) NIL)
	(T
	 (LIST
	  (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N))))))

(DEFUN PRUP(VARS N)
  (COND	((NULL VARS) NIL)
	(T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))

(DEFUN MKPUSH(N M)
  (COND	((LESSP N M) NIL)
	(T
	 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
	       (MKPUSH N (ADD1 M))))))

(DEFUN COMPEXP(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((OR (EQ EXP (QUOTE T)) (NUMBERP EXP))
	 (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP)
	 (LIST
	  (LIST	(QUOTE MOVE)
		1
		(PLUS M (CDR (ASSOC EXP VPR)))
		(QUOTE P))))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ@)
		       1
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HLRZ@ 1 1)))))))
	((EQ (CAR EXP) (QUOTE CDR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HRRZ@)
		       1
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HRRZ@ 1 1)))))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT))
	     (EQ (CAR EXP) (QUOTE EQ)))
	 ((LAMBDA(L1 L2)
	   (LIST (COMBOOL EXP M L1 NIL VPR)
		 (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		       (LIST (QUOTE JRST) 0 L2)
		       (LIST (QUOTE LABEL) L1)
		       (QUOTE (MOVEI 1 0))
		       (LIST (QUOTE LABEL) L2))))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND))
	 (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE))
	 (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 (LIST (COMPLISA (CDR EXP) M VPR)
	       (LIST
		(LIST (QUOTE CALL)
		      (LENGTH (CDR EXP))
		      (LIST 'QUOTE (CAR EXP))
		      ))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (LIST (STACKUP (CDR EXP) M VPR)
		 (COMPEXP
		  (CADDAR EXP)
		  (DIFFERENCE M N)
		  (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR)) ;APEND?
		 (SUBSTACK N)))
	  (LENGTH (CDR EXP))))
	((QUOTE T) (QUOTE NIL))))

(DEFUN STACKUP(U M VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMPEXP (CAR U) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (STACKUP (CDR U) (SUB1 M) VPR)))))

(DEFUN CCCHAIN(EXP)
  (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR)))
       (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))

(DEFUN COMPC(EXP N2 M VPR)
  (COND	((ATOM EXP) (ERROR (QUOTE COMPC)))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ@)
		       N2
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(CONS (LIST (QUOTE HLRZ@) N2 N2)
		      (COMPC (CADR EXP) N2 M VPR)))))
	((ATOM (CADR EXP))
	 (LIST
	  (LIST	(QUOTE HRRZ@)
		N2
		(PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		(QUOTE P))))
	(T
	 (CONS (LIST (QUOTE HRRZ@) N2 N2)
	       (COMPC (CADR EXP) N2 M VPR)))))

(DEFUN COMCOND(U M L VPR)
  (COND	((NULL U) (LIST (LIST (QUOTE LABEL) L)))
	((AND (NOT (ATOM (CAAR U)))
	      (EQ (CAAAR U) (QUOTE NULL))
	      (NULL (CADAR U)))
	 (LIST (COMPEXP (CADAAR U) M VPR)
	       (LIST (LIST (QUOTE JUMPE) 1 L))
	       (COMCOND (CDR U) M L VPR)))
	((EQ (CAAR U) (QUOTE T))
	 (LIST (COMPEXP (CADAR U) M VPR)
	       (LIST (LIST (QUOTE LABEL) L))))
	(T
	 ((LAMBDA(L1)
	   (LIST (COMBOOL (CAAR U) M L1 NIL VPR)
		 (COMPEXP (CADAR U) M VPR)
		 (LIST (LIST (QUOTE JRST) 0 L)
		       (LIST (QUOTE LABEL) L1))
		 (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))

(DEFUN COMPLISA(U M VPR)
  ((LAMBDA(Z)
    (LIST (COMPLIS Z M 1 VPR)
	  (LOADAC Z
		  (DIFFERENCE 1 (CCOUNT Z))
		  1
		  (DIFFERENCE M (CCOUNT Z))
		  VPR)
	  (SUBSTACK (CCOUNT Z))))
   (CLASSIFY U)))

(DEFUN CCOUNT(Z)
  (COND	((NULL Z) 0)
	((= (CAAR Z) 4) (ADD1(CCOUNT (CDR Z))))
	(T (CCOUNT (CDR Z)))))

(DEFUN LOADAC(Z M2 N2 M VPR)
  (COND	((NULL Z) NIL)
	((= (CAAR Z) 1)
	 (CONS (LIST (QUOTE MOVE)
		     N2
		     (PLUS M (CDR (ASSOC (CDAR Z) VPR)))
		     (QUOTE P))
	       (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 0)
	 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z)))
	       (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 2)
	 (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z))
	       (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 3)
	 (LIST (REVERSE (COMPC (CDAR Z) N2 M VPR))
	       (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 5) (LOADAC (CDR Z) 1 (ADD1 N2) M VPR))
	(T
	 (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P))
	       (LOADAC (CDR Z) (ADD1 M2) (ADD1 N2) M VPR)))))

(DEFUN COMPLIS(Z M K VPR)
  (COND	((NULL Z) NIL)
	((= (CAAR Z) 4)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (COMPLIS (CDR Z) (SUB1 M) (ADD1 K) VPR)))
	((= (CAAR Z) 5)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (COND ((= K 1) NIL)
		     (T (LIST (LIST (QUOTE MOVE) K 1))))))
	(T (COMPLIS (CDR Z) M (ADD1 K) VPR))))

(DEFUN CLASSIFY(U) (CLASS2 (CLASS1 U NIL) NIL T))

(DEFUN CLASS1(U V)
  (COND	((NULL U) V)
	((ATOM (CAR U))
	 (COND ((OR (EQUAL (CAR U) (QUOTE NIL))
		    (EQUAL (CAR U) (QUOTE T))
		    (NUMBERP (CAR U)))
		(CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
	       (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
	((EQUAL (CAAR U) (QUOTE QUOTE))
	 (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
	((CCCHAIN (CAR U))
	 (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
	(T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))

(DEFUN CLASS2(U V FLG)
  (COND	((NULL U) V)
	((AND FLG (= (CAAR U) 4))
	 (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
	(T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))

(DEFUN MKJRST(L) (LIST (LIST (QUOTE JRST) 0 L)))

(DEFUN COMBOOL(P M L FLG VPR)
  (COND	((EQ P (QUOTE T)) (COND (FLG (MKJRST L)) (T NIL)))
	((ATOM P)
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))
	((EQ (CAR P) (QUOTE EQ))
	 (LIST (COMPLISA (CDR P) M VPR)
	       (COND (FLG (QUOTE ((CAMN 1 2))))
		     (T (QUOTE ((CAME 1 2)))))
	       (MKJRST L)))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L NIL VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L T VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT))
	 (COMBOOL (CADR P) M L (NOT FLG) VPR))
	((EQ (CAR P) (QUOTE NULL))
	 (LIST (COMPEXP (CADR P) M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPE)) (T (QUOTE JUMPN)))
		      1
		      L))))
	(T
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))))

(DEFUN COMPANDOR(U M L FLG VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR (CDR U) M L FLG VPR)))))

(DEFUN COMPANDOR1(U M L L2 FLG VPR)
  (COND	((NULL U) (MKJRST L2))
	((NULL (CDR U)) (COMBOOL (CAR U) M L2 (NOT FLG) VPR))
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR1 (CDR U) M L L2 FLG VPR)))))

(DEFUN FLAT(U S)
  (COND	((NULL U) S)
	((NULL (CAR U)) (FLAT (CDR U) S))
	((EQ (CAR U) (QUOTE LABEL)) (CONS (CADR U) S))
	((ATOM (CAR U)) (CONS U S))
	(T (FLAT (CAR U) (FLAT (CDR U) S)))))